Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/P4⁄Mac 2.0d4/Mac source 2.0/pcode.p

Text File | 1996-09-28 | 37.9 KB | 1,836 lines | [TEXT/PJMM]

(*Assembler and interpreter of Pascal code*)
(*K. Jensen, N. Wirth, Ch. Jacobi, ETH May 76*)

{Mac port by Ingemar Ragnemalm 1994-1996. Look for "{” comments to find my changes.}

unit pcode;
{(input, output, prd, prr);}
interface
    uses
{$IFC UNDEFINED THINK_PASCAL}
        Types, QuickDraw, Windows, Dialogs, ToolUtils, Events, Controls, {}
        Memory, Sound, OSUtils, MixedMode,
{$ENDC}
        NewOldFile, Messages, Console;

    procedure InitInterpreter;
    procedure RunInterpreter (oldFile: Str255);

implementation


(* Note for the implementation.}
{   ===========================}
{This interpreter is written for the case where all the fundamental types}
{take one storage unit.}
{In an actual implementation, the handling of the sp pointer has to take}
{into account the fact that the types may have lengths different from one:}
{in push and pop operations the sp has to be increased and decreased not}
{by 1, but by a number depending on the type concerned.}
{However, where the number of units of storage has been computed by the}
{compiler, the value must not be corrected, since the lengths of the types}
{involved have already been taken into account.}
{                                 *)

    procedure InitInterpreter;
    begin
    end;



    const
        codemax = 8650;
        pcmax = 17500;
        maxstk = 13650; (* size of variable store *)
        overi = 13655; (* size of integer constant table = 5 *)
        overr = 13660; (* size of real constant table = 5 *)
        overs = 13730; (* size of set constant table = 70 *)
        overb = 13820;
        overm = 18000;
        maxstr = 18001;
        largeint = 26144;
        begincode = 3;
        inputadr = 5;
        outputadr = 6;
        prdadr = 7;
        prradr = 8;
        duminst = 62;

    type
        bit4 = 0..15;
        bit6 = 0..127;
        bit20 = -26143..26143;
        datatype = (undef, int, reel, bool, sett, adr, mark, car);
        address = -1..maxstr;
        beta = string[25]; {IR: Was: packed array[1..25] of char;}
 (*error message*)
        settype = set of 0..58;
        alfa = packed array[1..10] of char;

        codeType = array[0..codemax] of packed record   (* the program *)
                op1: bit6;
                p1: bit4;
                q1: bit20;
                op2: bit6;
                p2: bit4;
                q2: bit20
            end;
        codePtr = ^codeType;

        storeType = array[0..overm] of record
                case datatype of
                    int: (
                            vi: integer
                    );
                    reel: (
                            vr: real
                    );
                    bool: (
                            vb: boolean
                    );
                    sett: (
                            vs: settype
                    );
                    car: (
                            vc: char
                    );
                    adr: (
                            va: address
                    );
                         (*address in store*)
                    mark: (
                            vm: integer
                    )
            end;
        storePtr = ^storeType;

    var
        code: codePtr;

        pc: 0..pcmax;     (*program address register*)
        op: bit6;
        p: bit4;
        q: bit20;  (*instruction register*)

        store: storePtr;

{Ovanstående variabler är utanför för att store och code skall vara statiska.}

    procedure RunInterpreter (oldFile: Str255);

        var
            mp, sp, np, ep: address;  (* address registers *)
       (*mp  points to beginning of a data segment}
{     sp  points to top of the stack}
{     ep  points to the maximum extent of the stack}
{     np  points to top of the dynamically allocated area*)

            interpreting: boolean;
            prd, prr: text;(*prd for read only, prr for write only *)

            instr: array[bit6] of alfa; (* mnemonic instruction codes *)
            cop: array[bit6] of integer;
            sptable: array[0..20] of alfa; (*standard functions and procedures*)

      (*locally used for interpreting one instruction*)
            ad, ad1: address;
            b: boolean;
            i, j, i1, i2: integer;
            c: char;

        label
            1;

(*--------------------------------------------------------------------*)

        procedure load;
            const
                maxlabel = 1850;
            type
                labelst = (entered, defined); (*label situation*)
                labelrg = 0..maxlabel;       (*label range*)
                labelrec = record
                        val: address;
                        st: labelst
                    end;
            var
                icp, rcp, scp, bcp, mcp: address;  (*pointers to next free position*)
                word: array[1..10] of char;
                i: integer;
                ch: char;
                labeltab: array[labelrg] of labelrec;
                labelvalue: address;

            procedure init;
                var
                    i: integer;
            begin
                instr[0] := 'lod       ';
                instr[1] := 'ldo       ';
                instr[2] := 'str       ';
                instr[3] := 'sro       ';
                instr[4] := 'lda       ';
                instr[5] := 'lao       ';
                instr[6] := 'sto       ';
                instr[7] := 'ldc       ';
                instr[8] := '...       ';
                instr[9] := 'ind       ';
                instr[10] := 'inc       ';
                instr[11] := 'mst       ';
                instr[12] := 'cup       ';
                instr[13] := 'ent       ';
                instr[14] := 'ret       ';
                instr[15] := 'csp       ';
                instr[16] := 'ixa       ';
                instr[17] := 'equ       ';
                instr[18] := 'neq       ';
                instr[19] := 'geq       ';
                instr[20] := 'grt       ';
                instr[21] := 'leq       ';
                instr[22] := 'les       ';
                instr[23] := 'ujp       ';
                instr[24] := 'fjp       ';
                instr[25] := 'xjp       ';
                instr[26] := 'chk       ';
                instr[27] := 'eof       ';
                instr[28] := 'adi       ';
                instr[29] := 'adr       ';
                instr[30] := 'sbi       ';
                instr[31] := 'sbr       ';
                instr[32] := 'sgs       ';
                instr[33] := 'flt       ';
                instr[34] := 'flo       ';
                instr[35] := 'trc       ';
                instr[36] := 'ngi       ';
                instr[37] := 'ngr       ';
                instr[38] := 'sqi       ';
                instr[39] := 'sqr       ';
                instr[40] := 'abi       ';
                instr[41] := 'abr       ';
                instr[42] := 'not       ';
                instr[43] := 'and       ';
                instr[44] := 'ior       ';
                instr[45] := 'dif       ';
                instr[46] := 'int       ';
                instr[47] := 'uni       ';
                instr[48] := 'inn       ';
                instr[49] := 'mod       ';
                instr[50] := 'odd       ';
                instr[51] := 'mpi       ';
                instr[52] := 'mpr       ';
                instr[53] := 'dvi       ';
                instr[54] := 'dvr       ';
                instr[55] := 'mov       ';
                instr[56] := 'lca       ';
                instr[57] := 'dec       ';
                instr[58] := 'stp       ';
                instr[59] := 'ord       ';
                instr[60] := 'chr       ';
                instr[61] := 'ujc       ';

                sptable[0] := 'get       ';
                sptable[1] := 'put       ';
                sptable[2] := 'rst       ';
                sptable[3] := 'rln       ';
                sptable[4] := 'new       ';
                sptable[5] := 'wln       ';
                sptable[6] := 'wrs       ';
                sptable[7] := 'eln       ';
                sptable[8] := 'wri       ';
                sptable[9] := 'wrr       ';
                sptable[10] := 'wrc       ';
                sptable[11] := 'rdi       ';
                sptable[12] := 'rdr       ';
                sptable[13] := 'rdc       ';
                sptable[14] := 'sin       ';
                sptable[15] := 'cos       ';
                sptable[16] := 'exp       ';
                sptable[17] := 'log       ';
                sptable[18] := 'sqt       ';
                sptable[19] := 'atn       ';
                sptable[20] := 'sav       ';

                cop[0] := 105;
                cop[1] := 65;
                cop[2] := 70;
                cop[3] := 75;
                cop[6] := 80;
                cop[9] := 85;
                cop[10] := 90;
                cop[26] := 95;
                cop[57] := 100;

                pc := begincode;
                icp := maxstk + 1;
                rcp := overi + 1;
                scp := overr + 1;
                bcp := overs + 2;
                mcp := overb + 1;
                for i := 1 to 10 do
                    word[i] := ' ';
                for i := 0 to maxlabel do
                    with labeltab[i] do
                        begin
                            val := -1;
                            st := entered
                        end;
                reset(prd);
            end;(*init*)

            procedure errorl (theString: beta); (*error in loading*)
            begin
                WriteLnMessage;                    {was writeln}
                WriteMessage(theString);        {was write}
                Exit(RunInterpreter);             {was halt}
            end; (*errorl*)

            procedure update (x: labelrg); (*when a label definition lx is found*)
                var
                    curr, succ: -1..pcmax;  (*resp. current element and successor element}
{                   of a list of future references*)
                    endlist: boolean;
            begin
                if labeltab[x].st = defined then
                    errorl(' duplicated label           ')
                else
                    begin
                        if labeltab[x].val <> -1 then (*forward reference(s)*)
                            begin
                                curr := labeltab[x].val;
                                endlist := false;
                                while not endlist do
                                    with code^[curr div 2] do
                                        begin
                                            if odd(curr) then
                                                begin
                                                    succ := q2;
                                                    q2 := labelvalue
                                                end
                                            else
                                                begin
                                                    succ := q1;
                                                    q1 := labelvalue
                                                end;
                                            if succ = -1 then
                                                endlist := true
                                            else
                                                curr := succ
                                        end;
                            end;
                        labeltab[x].st := defined;
                        labeltab[x].val := labelvalue;
                    end
            end;(*update*)

            procedure assemble;
            forward;

            procedure generate;(*generate segment of code*)
                var
                    x: integer; (* label number *)
                    again: boolean;
            begin
                again := true;
                while again do
                    begin
                        read(prd, ch);(* first character of line*)
                        case ch of
                            'i':
                                readln(prd);
                            'l':
                                begin
                                    read(prd, x);
                                    if not eoln(prd) then
                                        read(prd, ch);
                                    if ch = '=' then
                                        read(prd, labelvalue)
                                    else
                                        labelvalue := pc;
                                    update(x);
                                    readln(prd);
                                end;
                            'q':
                                begin
                                    again := false;
                                    readln(prd)
                                end;
                            ' ':
                                begin
                                    read(prd, ch);
                                    assemble
                                end
                        end;
                    end
            end; (*generate*)

            procedure assemble; (*translate symbolic code into machine code and store*)
                label
                    1;     (*goto 1 for instructions without code generation*)
                var
                    name: alfa;
                    b: boolean;
                    r: real;
                    s: settype;
                    c1: char;
                    i, s1, lb, ub: integer;

                procedure lookup (x: labelrg); (* search in label table*)
                begin
                    case labeltab[x].st of
                        entered:
                            begin
                                q := labeltab[x].val;
                                labeltab[x].val := pc
                            end;
                        defined:
                            q := labeltab[x].val
                    end(*case label..*)
                end;(*lookup*)

                procedure labelsearch;
                    var
                        x: labelrg;
                begin
                    while (ch <> 'l') and not eoln(prd) do
                        read(prd, ch);
                    read(prd, x);
                    lookup(x)
                end;(*labelsearch*)

                procedure getname;
                    var
                        i: integer; {fix for pack}
                begin
                    word[1] := ch;
                    read(prd, word[2], word[3]);
                    if not eoln(prd) then
                        read(prd, ch); (*next character*)
{pack(word, 1, name) doesn't exist, replace by:}
                    for i := 1 to 10 do {pack}
                        name[i] := word[i]; {pack}
                end; (*getname*)

                procedure typesymbol;
                    var
                        i: integer;
                begin
                    if ch <> 'i' then
                        begin
                            case ch of
                                'a':
                                    i := 0;
                                'r':
                                    i := 1;
                                's':
                                    i := 2;
                                'b':
                                    i := 3;
                                'c':
                                    i := 4;
                            end;
                            op := cop[op] + i;
                        end;
                end; (*typesymbol*)

            begin
                p := 0;
                q := 0;
                op := 0;
                getname;
                instr[duminst] := name;
                while instr[op] <> name do
                    op := op + 1;
                if op = duminst then
                    errorl(' illegal instruction     ');

                case op of  (* get parameters p,q *)

      (*equ,neq,geq,grt,leq,les*)
                    17, 18, 19, 20, 21, 22:
                        begin
                            case ch of
                                'a':
                                    ; (*p = 0*)
                                'i':
                                    p := 1;
                                'r':
                                    p := 2;
                                'b':
                                    p := 3;
                                's':
                                    p := 4;
                                'c':
                                    p := 6;
                                'm':
                                    begin
                                        p := 5;
                                        read(prd, q)
                                    end
                            end
                        end;

      (*lod,str*)
                    0, 2:
                        begin
                            typesymbol;
                            read(prd, p, q)
                        end;

4  (*lda*)
                    :
                        read(prd, p, q);

12 (*cup*)
                    :
                        begin
                            read(prd, p);
                            labelsearch
                        end;

11 (*mst*)
                    :
                        read(prd, p);

14 (*ret*)
                    :
                        case ch of
                            'p':
                                p := 0;
                            'i':
                                p := 1;
                            'r':
                                p := 2;
                            'c':
                                p := 3;
                            'b':
                                p := 4;
                            'a':
                                p := 5
                        end;

      (*lao,ixa,mov*)
                    5, 16, 55:
                        read(prd, q);

      (*ldo,sro,ind,inc,dec*)
                    1, 3, 9, 10, 57:
                        begin
                            typesymbol;
                            read(prd, q)
                        end;

      (*ujp,fjp,xjp*)
                    23, 24, 25:
                        labelsearch;

13 (*ent*)
                    :
                        begin
                            read(prd, p);
                            labelsearch
                        end;

15 (*csp*)
                    :
                        begin
                            for i := 1 to 9 do
                                read(prd, ch);
                            getname;
                            while name <> sptable[q] do
                                q := q + 1
                        end;

7 (*ldc*)
                    :
                        begin
                            case ch of  (*get q*)
                                'i':
                                    begin
                                        p := 1;
                                        read(prd, i);
                                        if abs(i) >= largeint then
                                            begin
                                                op := 8;
                                                store^[icp].vi := i;
                                                q := maxstk;
                                                repeat
                                                    q := q + 1
                                                until store^[q].vi = i;
                                                if q = icp then
                                                    begin
                                                        icp := icp + 1;
                                                        if icp = overi then
                                                            errorl(' integer table overflow  ');
                                                    end
                                            end
                                        else
                                            q := i
                                    end;

                                'r':
                                    begin
                                        op := 8;
                                        p := 2;
                                        read(prd, r);
                                        store^[rcp].vr := r;
                                        q := overi;
                                        repeat
                                            q := q + 1
                                        until store^[q].vr = r;
                                        if q = rcp then
                                            begin
                                                rcp := rcp + 1;
                                                if rcp = overr then
                                                    errorl(' real table overflow     ');
                                            end
                                    end;

                                'n':
                                    ; (*p,q = 0*)

                                'b':
                                    begin
                                        p := 3;
                                        read(prd, q)
                                    end;

                                'c':
                                    begin
                                        p := 6;
                                        repeat
                                            read(prd, ch);
                                        until ch <> ' ';
                                        if ch <> '''' then
                                            errorl(' illegal character       ');
                                        read(prd, ch);
                                        q := ord(ch);
                                        read(prd, ch);
                                        if ch <> '''' then
                                            errorl(' illegal character       ');
                                    end;
                                '(':
                                    begin
                                        op := 8;
                                        p := 4;
                                        s := [];
                                        read(prd, ch);
                                        while ch <> ')' do
                                            begin
                                                read(prd, s1, ch);
                                                s := s + [s1]
                                            end;
                                        store^[scp].vs := s;
                                        q := overr;
                                        repeat
                                            q := q + 1
                                        until store^[q].vs = s;
                                        if q = scp then
                                            begin
                                                scp := scp + 1;
                                                if scp = overs then
                                                    errorl(' set table overflow      ');
                                            end
                                    end
                            end (*case*)
                        end;

26 (*chk*)
                    :
                        begin
                            typesymbol;
                            read(prd, lb, ub);
                            if op = 95 then
                                q := lb
                            else
                                begin
                                    store^[bcp - 1].vi := lb;
                                    store^[bcp].vi := ub;
                                    q := overs;
                                    repeat
                                        q := q + 2
                                    until (store^[q - 1].vi = lb) and (store^[q].vi = ub);
                                    if q = bcp then
                                        begin
                                            bcp := bcp + 2;
                                            if bcp = overb then
                                                errorl(' boundary table overflow ');
                                        end
                                end
                        end;

56 (*lca*)
                    :
                        begin
                            if mcp + 16 >= overm then
                                errorl(' multiple table overflow ');
                            mcp := mcp + 16;
                            q := mcp;
                            for i := 0 to 15 do (*stringlgth*)
                                begin
                                    read(prd, ch);
                                    store^[q + i].vc := ch
                                end;
                        end;

6 (*sto*)
                    :
                        typesymbol;

                    27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 58:
                        ;

      (*ord,chr*)
                    59, 60:
                        goto 1;

61 (*ujc*)
                    :
                        ; (*must have same length as ujp*)

                end; (*case*)

      (* store instruction *)
                with code^[pc div 2] do
                    if odd(pc) then
                        begin
                            op2 := op;
                            p2 := p;
                            q2 := q
                        end
                    else
                        begin
                            op1 := op;
                            p1 := p;
                            q1 := q
                        end;
                pc := pc + 1;
1:
                readln(prd);
            end; (*assemble*)

        begin (*load*)
            init;
            generate;
            pc := 0;
            generate;
        end; (*load*)

(*------------------------------------------------------------------------*)

        procedure pmd;
            var
                s: integer;
                i: integer;

            procedure pt;
            begin
                ConsoleWrite(StringOf(s : 6));
                if abs(store^[s].vi) < maxint then
                    ConsoleWrite(StringOf(store^[s].vi))
                else
                    ConsoleWrite('too big ');
                s := s - 1;
                i := i + 1;
                if i = 4 then
                    begin
                        ConsoleNewLine;            {writeln(output);}
                        i := 0
                    end;
            end; (*pt*)

        begin
            ConsoleWrite(StringOf(' pc =', pc - 1 : 5, ' op =', op : 3, '  sp =', sp : 5, '  mp =', mp : 5, '  np =', np : 5));
            ConsoleNewLine;
            ConsoleWriteLn('--------------------------------------');

            s := sp;
            i := 0;
            while s >= 0 do
                pt;
            s := maxstk;
            while s >= np do
                pt;
        end; (*pmd*)

        procedure errori (theString: beta);
        begin
            ConsoleNewLine;
            ConsoleWriteLn(theString);
            pmd;
            goto 1
        end;(*errori*)

        function base (ld: integer): address;
            var
                ad: address;
        begin
            ad := mp;
            while ld > 0 do
                begin
                    ad := store^[ad + 1].vm;
                    ld := ld - 1
                end;
            base := ad
        end; (*base*)

        procedure compare;
(*comparing is only correct if result by comparing integers will be*)
        begin
            i1 := store^[sp].va;
            i2 := store^[sp + 1].va;
            i := 0;
            b := true;
            while b and (i <> q) do
                if store^[i1 + i].vi = store^[i2 + i].vi then
                    i := i + 1
                else
                    b := false
        end; (*compare*)


        var
            prrOpen: Boolean;

        procedure CheckPrr; {Fix to avoid a prr file if we don't need it!}
            var
                newFile: Str255;
        begin
            if prrOpen then
                exit(CheckPrr);
{            newFile := 'p4.err';}
{            newFile := GetOutFile('Output file?', '');    Equivalent to NewFileName!}
            newFile := NewFileName('Output file?');
            rewrite(prr, newFile);
        end;


        procedure callsp;
            var
                line: boolean;
                adptr, adelnt: address;
                i: integer;

            procedure readi (var f: text);
                var
                    ad: address;
            begin
                ad := store^[sp - 1].va;
                if @f = @input then
                    begin
                        store^[ad].vi := ConsoleReadInt;
                        store^[store^[sp].va].vc := ConsolePeekChar;
                    end
                else
                    begin
                        read(f, store^[ad].vi);
                        store^[store^[sp].va].vc := f^;
                    end;
                sp := sp - 2
            end;(*readi*)

            procedure readr (var f: text);
                var
                    ad: address;
            begin
                ad := store^[sp - 1].va;
                if @f = @input then
                    begin
                        store^[ad].vr := ConsoleReadReal;
                        store^[store^[sp].va].vc := ConsolePeekChar;
                    end
                else
                    begin
                        read(f, store^[ad].vr);
                        store^[store^[sp].va].vc := f^;
                    end;
                sp := sp - 2
            end;(*readr*)

            procedure readc (var f: text);
                var
                    c: char;
                    ad: address;
            begin
                if @f = @input then
                    c := ConsoleReadChar
                else
                    read(f, c);
                ad := store^[sp - 1].va;
                store^[ad].vc := c;
                if @f = @input then
                    begin
                        store^[store^[sp].va].vc := ConsolePeekChar;            {???}
                        store^[store^[sp].va].vi := ord(store^[store^[sp].va].vc);
                    end
                else
                    begin
                        store^[store^[sp].va].vc := f^;
                        store^[store^[sp].va].vi := ord(f^);
                    end;
                sp := sp - 2
            end;(*readc*)

            procedure writestr (var f: text);
                var
                    i, j, k: integer;
                    ad: address;
            begin
                ad := store^[sp - 3].va;
                k := store^[sp - 2].vi;
                j := store^[sp - 1].vi;
     (* j and k are numbers of characters *)
                if k > j then
                    for i := 1 to k - j do
                        if @f = @output then
                            ConsoleWrite(' ')
                        else
                            write(f, ' ')
                else
                    j := k;
                for i := 0 to j - 1 do
                    if @f = @output then
                        ConsoleWrite(store^[ad + i].vc)
                    else
                        write(f, store^[ad + i].vc);
                sp := sp - 4
            end;(*writestr*)

            procedure getfile (var f: text);
                var
                    ad: address;
            begin
                ad := store^[sp].va;
                if @f = @input then
                    store^[ad].vc := ConsoleReadChar
                else
                    begin
                        get(f);
                        store^[ad].vc := f^;
                    end;
                sp := sp - 1
            end;(*getfile*)

            procedure putfile (var f: text);
                var
                    ad: address;
            begin
                ad := store^[sp].va;
                if @f = @output then
                    ConsoleWrite(store^[ad].vc)
                else
                    begin
                        f^ := store^[ad].vc;
                        put(f);
                    end;
                sp := sp - 1;
            end;(*putfile*)

        begin (*callsp*)
            case q of
0 (*get*)
                :
                    case store^[sp].va of
                        5:
                            ConsoleGet;                {getfile(input)}
                        6:
                            errori(' get on output file      ');
                        7:
                            getfile(prd);
                        8:
                            errori(' get on prr file     ')
                    end;
1 (*put*)
                :
                    case store^[sp].va of
                        5:
                            errori(' put on read file    ');
                        6:
                            ;
{putfile(output)                VAD skall skrivas var då??? Behövs en output^???}
                        7:
                            errori(' put on prd file     ');
                        8:
                            begin
                                CheckPrr; {Fix to avoid a prr file if we don't need it!}
                                putfile(prr)
                            end;
                    end;
2 (*rst*)
                :
                    begin
            (*for testphase*)
                        np := store^[sp].va;
                        sp := sp - 1
                    end;
3 (*rln*)
                :
                    begin
                        case store^[sp].va of
                            5:
                                begin
                                    store^[inputadr].vc := ConsoleReadChar;
{readln(input);store ^ [ inputadr ] . vc := input ^}
                                end;
                            6:
                                errori(' readln on output file   ');
                            7:
                                begin
                                    store^[inputadr].vc := ConsoleReadChar;
{readln(input);store^[inputadr].vc := input^}
                                end;
                            8:
                                errori(' readln on prr file      ')
                        end;
                        sp := sp - 1
                    end;
4 (*new*)
                :
                    begin
                        ad := np - store^[sp].va;
              (*top of stack gives the length in units of storage *)
                        if ad <= ep then
                            errori(' store overflow      ');
                        np := ad;
                        ad := store^[sp - 1].va;
                        store^[ad].va := np;
                        sp := sp - 2
                    end;
5 (*wln*)
                :
                    begin
                        case store^[sp].va of
                            5:
                                errori(' writeln on input file   ');
                            6:
                                ConsoleNewLine;                {writeln(output);}
                            7:
                                errori(' writeln on prd file     ');
                            8:
                                begin
                                    CheckPrr; {Fix to avoid a prr file if we don't need it!}
                                    writeln(prr)
                                end;
                        end;
                        sp := sp - 1
                    end;
6 (*wrs*)
                :
                    case store^[sp].va of
                        5:
                            errori(' write on input file     ');
                        6:
                            writestr(output);
                        7:
                            errori(' write on prd file       ');
                        8:
                            begin
                                CheckPrr; {Fix to avoid a prr file if we don't need it!}
                                writestr(prr)
                            end;
                    end;
7 (*eln*)
                :
                    begin
                        case store^[sp].va of
                            5:
                                line := eoln(input);
                            6:
                                errori(' eoln output file    ');
                            7:
                                line := eoln(prd);
                            8:
                                errori(' eoln on prr file    ')
                        end;
                        store^[sp].vb := line
                    end;
8 (*wri*)
                :
                    begin
                        case store^[sp].va of
                            5:
                                errori(' write on input file     ');
                            6:
                                ConsoleWrite(StringOf(store^[sp - 2].vi : store^[sp - 1].vi));
                            7:
                                errori(' write on prd file       ');
                            8:
                                begin
                                    CheckPrr; {Fix to avoid a prr file if we don't need it!}
                                    write(prr, store^[sp - 2].vi : store^[sp - 1].vi)
                                end;
                        end;
                        sp := sp - 3
                    end;
9 (*wrr*)
                :
                    begin
                        case store^[sp].va of
                            5:
                                errori(' write on input file     ');
                            6:
                                ConsoleWrite(StringOf(store^[sp - 2].vr : store^[sp - 1].vi));        {write(output,}
                            7:
                                errori(' write on prd file       ');
                            8:
                                begin
                                    CheckPrr; {Fix to avoid a prr file if we don't need it!}
                                    write(prr, store^[sp - 2].vr : store^[sp - 1].vi)
                                end;
                        end;
                        sp := sp - 3
                    end;
10(*wrc*)
                :
                    begin
                        case store^[sp].va of
                            5:
                                errori(' write on input file     ');
                            6:
                                ConsoleWrite(StringOf(store^[sp - 2].vc : store^[sp - 1].vi));            {write(output,}
                            7:
                                errori(' write on prd file       ');
                            8:
                                begin
                                    CheckPrr; {Fix to avoid a prr file if we don't need it!}
                                    write(prr, chr(store^[sp - 2].vi) : store^[sp - 1].vi);
                                end;
                        end;
                        sp := sp - 3
                    end;
11(*rdi*)
                :
                    case store^[sp].va of
                        5:
                            readi(input);
                        6:
                            errori(' read on output file     ');
                        7:
                            readi(prd);
                        8:
                            errori(' read on prr file    ')
                    end;
12(*rdr*)
                :
                    case store^[sp].va of
                        5:
                            readr(input);
                        6:
                            errori(' read on output file     ');
                        7:
                            readr(prd);
                        8:
                            errori(' read on prr file    ')
                    end;
13(*rdc*)
                :
                    case store^[sp].va of
                        5:
                            readc(input);
                        6:
                            errori(' read on output file     ');
                        7:
                            readc(prd);
                        8:
                            errori(' read on prr file    ')
                    end;
14(*sin*)
                :
                    store^[sp].vr := sin(store^[sp].vr);
15(*cos*)
                :
                    store^[sp].vr := cos(store^[sp].vr);
16(*exp*)
                :
                    store^[sp].vr := exp(store^[sp].vr);
17(*log*)
                :
                    store^[sp].vr := ln(store^[sp].vr);
18(*sqt*)
                :
                    store^[sp].vr := sqrt(store^[sp].vr);
19(*atn*)
                :
                    store^[sp].vr := arctan(store^[sp].vr);
20(*sav*)
                :
                    begin
                        ad := store^[sp].va;
                        store^[ad].va := np;
                        sp := sp - 1
                    end;
            end;(*case q*)
        end;(*callsp*)

        function CommandPeriod: Boolean;
            var
                km: KeyMap;
        begin
            CommandPeriod := false;
            GetKeys(km);
            if km[47] and km[55] then
                CommandPeriod := true;
        end; {CommandPeriod}

        function oldGetInFile: Str255;
            var
                message, count: Integer;
{                theAppFile: AppFile;}
        begin
{AppFiles handling is obsolete.}
(*            CountAppFiles(message, count);}
{            if count > 0 then}
{                begin}
{                    GetAppFiles(1, theAppFile);}
{                    if SetVol(nil, theAppFile.vRefNum) <> noErr then}
{                        ; {We ignore errors for now}
{GetInFile := theAppFile.fname;}
{end}
{else}
{*)
            begin
                oldGetInFile := OldFileName('');
            end;
        end; {GetInFile}

{For Stdfile-dialogs:}
        var
{oldFile: Str255; - numera argument!}
            theTextRect: Rect;


    begin (* main *)
{theTextRect := screenBits.bounds;}
{theTextRect.top := theTextRect.top + 40; {For menu bar and window top}
{InsetRect(theTextRect, 10, 10);}
{SetRect(theTextRect, 40, 40, 300, 300);}
{SetTextRect(theTextRect);}
{ShowText;}
{WriteMessageLine('Welcome to the P4Mac p-code interpreter!');}
{WriteMessageLine('This program is based on the Public Domain compiler P4.');}
{WriteMessageLine('Quick port for the Mac by Ingemar Ragnemalm - and don''t ask me why.');}
{WriteMessageLine('•••');}

{Fix for Think Pascal's stupid 32k limit:}
        if code = nil then
            code := codePtr(NewPtr(sizeof(codeType)));
        if code = nil then
            begin
                SysBeep(1);
                WriteMessageLine(StringOf('Out of memory trying to allocate ', sizeof(codeType) : 1, ' bytes for "code".'));
                Exit(RunInterpreter);
            end;
        if store = nil then
            store := storePtr(NewPtr(sizeof(storeType)));
        if store = nil then
            begin
                SysBeep(1);
                WriteMessageLine(StringOf('Out of memory trying to allocate ', sizeof(storeType) : 1, ' bytes for "store".'));
                Exit(RunInterpreter);
            end;

{close(prd); {Behövs det?}

        if oldFile = '' then
            oldFile := GetInFile;
        reset(prd, oldFile);

{newFile := NewFileName('Output file?');}

{Borde inte rewrite'a prr förrän vi ser att det krävs nåt ut, väl?}
{rewrite(prr, newFile); {Var förr rewrite(prr)!!!}
        prrOpen := false; {Not open yet!}

        load; (* assembles and stores code *)
  (* writeln(output); for testing *)
        pc := 0;
        sp := -1;
        mp := 0;
        np := maxstk + 1;
        ep := 5;
{store^[inputadr].vc := input^;}
{store^[prdadr].vc := prd^; {???}
        interpreting := true;
        aborted := false;
        ConsoleResetRead;    {The read buffer must be cleared from the last run}

        while interpreting and not aborted do
            begin

                if CommandPeriod then
                    begin
                        ConsoleNewLine;
                        ConsoleWriteln('•••Execution terminated by user•••');
                        Exit(RunInterpreter);
                    end;

    (*fetch*)
                with code^[pc div 2] do
                    if odd(pc) then
                        begin
                            op := op2;
                            p := p2;
                            q := q2
                        end
                    else
                        begin
                            op := op1;
                            p := p1;
                            q := q1
                        end;
                pc := pc + 1;

    (*execute*)
                case op of

                    105, 106, 107, 108, 109, 0 (*lod*)
                    :
                        begin
                            ad := base(p) + q;
                            sp := sp + 1;
                            store^[sp] := store^[ad]
                        end;

                    65, 66, 67, 68, 69, 1 (*ldo*)
                    :
                        begin
                            sp := sp + 1;
                            store^[sp] := store^[q]
                        end;

                    70, 71, 72, 73, 74, 2 (*str*)
                    :
                        begin
                            store^[base(p) + q] := store^[sp];
                            sp := sp - 1
                        end;

                    75, 76, 77, 78, 79, 3 (*sro*)
                    :
                        begin
                            store^[q] := store^[sp];
                            sp := sp - 1
                        end;

4 (*lda*)
                    :
                        begin
                            sp := sp + 1;
                            store^[sp].va := base(p) + q
                        end;

5 (*lao*)
                    :
                        begin
                            sp := sp + 1;
                            store^[sp].va := q
                        end;

                    80, 81, 82, 83, 84, 6 (*sto*)
                    :
                        begin
                            store^[store^[sp - 1].va] := store^[sp];
                            sp := sp - 2;
                        end;

7 (*ldc*)
                    :
                        begin
                            sp := sp + 1;
                            if p = 1 then
                                begin
                                    store^[sp].vi := q;
                                end
                            else if p = 6 then
                                store^[sp].vc := chr(q)
                            else if p = 3 then
                                store^[sp].vb := q = 1
                            else (* load nil *)
                                store^[sp].va := maxstr
                        end;

8 (*lci*)
                    :
                        begin
                            sp := sp + 1;
                            store^[sp] := store^[q]
                        end;

                    85, 86, 87, 88, 89, 9 (*ind*)
                    :
                        begin
                            ad := store^[sp].va + q;
              (* q is a number of storage units *)
                            store^[sp] := store^[ad]
                        end;

                    90, 91, 92, 93, 94, 10 (*inc*)
                    :
                        store^[sp].vi := store^[sp].vi + q;

11 (*mst*)
                    :
                        begin (*p=level of calling procedure minus level of called}
{                  procedure + 1;  set dl and sl, increment sp*)
               (* then length of this element is}
{              max(intsize,realsize,boolsize,charsize,ptrsize *)
                            store^[sp + 2].vm := base(p);
               (* the length of this element is ptrsize *)
                            store^[sp + 3].vm := mp;
               (* idem *)
                            store^[sp + 4].vm := ep;
               (* idem *)
                            sp := sp + 5
                        end;

12 (*cup*)
                    :
                        begin (*p=no of locations for parameters, q=entry point*)
                            mp := sp - (p + 4);
                            store^[mp + 4].vm := pc;
                            pc := q
                        end;

13 (*ent*)
                    :
                        if p = 1 then
                            begin
                                sp := mp + q; (*q = length of dataseg*)
                                if sp > np then
                                    errori(' store overflow      ');
                            end
                        else
                            begin
                                ep := sp + q;
                                if ep > np then
                                    errori(' store overflow      ');
                            end;
            (*q = max space required on stack*)

14 (*ret*)
                    :
                        begin
                            case p of
                                0:
                                    sp := mp - 1;
                                1, 2, 3, 4, 5:
                                    sp := mp
                            end;
                            pc := store^[mp + 4].vm;
                            ep := store^[mp + 3].vm;
                            mp := store^[mp + 2].vm;
                        end;

15 (*csp*)
                    :
                        callsp;

16 (*ixa*)
                    :
                        begin
                            i := store^[sp].vi;
                            sp := sp - 1;
                            store^[sp].va := q * i + store^[sp].va;
                        end;

17 (*equ*)
                    :
                        begin
                            sp := sp - 1;
                            case p of
                                1:
                                    store^[sp].vb := store^[sp].vi = store^[sp + 1].vi;
                                0:
                                    store^[sp].vb := store^[sp].va = store^[sp + 1].va;
                                6:
                                    store^[sp].vb := store^[sp].vc = store^[sp + 1].vc;
                                2:
                                    store^[sp].vb := store^[sp].vr = store^[sp + 1].vr;
                                3:
                                    store^[sp].vb := store^[sp].vb = store^[sp + 1].vb;
                                4:
                                    store^[sp].vb := store^[sp].vs = store^[sp + 1].vs;
                                5:
                                    begin
                                        compare;
                                        store^[sp].vb := b;
                                    end;
                            end; (*case p*)
                        end;

18 (*neq*)
                    :
                        begin
                            sp := sp - 1;
                            case p of
                                0:
                                    store^[sp].vb := store^[sp].va <> store^[sp + 1].va;
                                1:
                                    store^[sp].vb := store^[sp].vi <> store^[sp + 1].vi;
                                6:
                                    store^[sp].vb := store^[sp].vc <> store^[sp + 1].vc;
                                2:
                                    store^[sp].vb := store^[sp].vr <> store^[sp + 1].vr;
                                3:
                                    store^[sp].vb := store^[sp].vb <> store^[sp + 1].vb;
                                4:
                                    store^[sp].vb := store^[sp].vs <> store^[sp + 1].vs;
                                5:
                                    begin
                                        compare;
                                        store^[sp].vb := not b;
                                    end
                            end; (*case p*)
                        end;

19 (*geq*)
                    :
                        begin
                            sp := sp - 1;
                            case p of
                                0:
                                    errori(' <,<=,>,>= for address   ');
                                1:
                                    store^[sp].vb := store^[sp].vi >= store^[sp + 1].vi;
                                6:
                                    store^[sp].vb := store^[sp].vc >= store^[sp + 1].vc;
                                2:
                                    store^[sp].vb := store^[sp].vr >= store^[sp + 1].vr;
                                3:
                                    store^[sp].vb := store^[sp].vb >= store^[sp + 1].vb;
                                4:
                                    store^[sp].vb := store^[sp].vs >= store^[sp + 1].vs;
                                5:
                                    begin
                                        compare;
                                        store^[sp].vb := b or (store^[i1 + i].vi >= store^[i2 + i].vi)
                                    end
                            end; (*case p*)
                        end;

20 (*grt*)
                    :
                        begin
                            sp := sp - 1;
                            case p of
                                0:
                                    errori(' <,<=,>,>= for address   ');
                                1:
                                    store^[sp].vb := store^[sp].vi > store^[sp + 1].vi;
                                6:
                                    store^[sp].vb := store^[sp].vc > store^[sp + 1].vc;
                                2:
                                    store^[sp].vb := store^[sp].vr > store^[sp + 1].vr;
                                3:
                                    store^[sp].vb := store^[sp].vb > store^[sp + 1].vb;
                                4:
                                    errori(' set inclusion       ');
                                5:
                                    begin
                                        compare;
                                        store^[sp].vb := not b and (store^[i1 + i].vi > store^[i2 + i].vi)
                                    end
                            end; (*case p*)
                        end;

21 (*leq*)
                    :
                        begin
                            sp := sp - 1;
                            case p of
                                0:
                                    errori(' <,<=,>,>= for address   ');
                                1:
                                    store^[sp].vb := store^[sp].vi <= store^[sp + 1].vi;
                                6:
                                    store^[sp].vb := store^[sp].vc <= store^[sp + 1].vc;
                                2:
                                    store^[sp].vb := store^[sp].vr <= store^[sp + 1].vr;
                                3:
                                    store^[sp].vb := store^[sp].vb <= store^[sp + 1].vb;
                                4:
                                    store^[sp].vb := store^[sp].vs <= store^[sp + 1].vs;
                                5:
                                    begin
                                        compare;
                                        store^[sp].vb := b or (store^[i1 + i].vi <= store^[i2 + i].vi)
                                    end;
                            end; (*case p*)
                        end;

22 (*les*)
                    :
                        begin
                            sp := sp - 1;
                            case p of
                                0:
                                    errori(' <,<=,>,>= for address   ');
                                1:
                                    store^[sp].vb := store^[sp].vi < store^[sp + 1].vi;
                                6:
                                    store^[sp].vb := store^[sp].vc < store^[sp + 1].vc;
                                2:
                                    store^[sp].vb := store^[sp].vr < store^[sp + 1].vr;
                                3:
                                    store^[sp].vb := store^[sp].vb < store^[sp + 1].vb;
                                5:
                                    begin
                                        compare;
                                        store^[sp].vb := not b and (store^[i1 + i].vi < store^[i2 + i].vi)
                                    end
                            end; (*case p*)
                        end;

23 (*ujp*)
                    :
                        pc := q;

24 (*fjp*)
                    :
                        begin
                            if not store^[sp].vb then
                                pc := q;
                            sp := sp - 1
                        end;

25 (*xjp*)
                    :
                        begin
                            pc := store^[sp].vi + q;
                            sp := sp - 1
                        end;

95 (*chka*)
                    :
                        if (store^[sp].va < np) or (store^[sp].va > (maxstr - q)) then
                            errori(' bad pointer value       ');

                    96, 97, 98, 99, 26 (*chk*)
                    :
                        if (store^[sp].vi < store^[q - 1].vi) or (store^[sp].vi > store^[q].vi) then
                            errori(' value out of range      ');

27 (*eof*)
                    :
                        begin
                            i := store^[sp].vi;
                            if i = inputadr then
                                begin
                                    store^[sp].vb := eof(input);
                                end
                            else
                                errori(' code in error       ')
                        end;

28 (*adi*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vi := store^[sp].vi + store^[sp + 1].vi
                        end;

29 (*adr*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vr := store^[sp].vr + store^[sp + 1].vr
                        end;

30 (*sbi*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vi := store^[sp].vi - store^[sp + 1].vi
                        end;

31 (*sbr*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vr := store^[sp].vr - store^[sp + 1].vr
                        end;

32 (*sgs*)
                    :
                        store^[sp].vs := [store^[sp].vi];

33 (*flt*)
                    :
                        store^[sp].vr := store^[sp].vi;

34 (*flo*)
                    :
                        store^[sp - 1].vr := store^[sp - 1].vi;

35 (*trc*)
                    :
                        store^[sp].vi := trunc(store^[sp].vr);

36 (*ngi*)
                    :
                        store^[sp].vi := -store^[sp].vi;

37 (*ngr*)
                    :
                        store^[sp].vr := -store^[sp].vr;

38 (*sqi*)
                    :
                        store^[sp].vi := sqr(store^[sp].vi);

39 (*sqr*)
                    :
                        store^[sp].vr := sqr(store^[sp].vr);

40 (*abi*)
                    :
                        store^[sp].vi := abs(store^[sp].vi);

41 (*abr*)
                    :
                        store^[sp].vr := abs(store^[sp].vr);

42 (*not*)
                    :
                        store^[sp].vb := not store^[sp].vb;

43 (*and*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vb := store^[sp].vb and store^[sp + 1].vb
                        end;

44 (*ior*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vb := store^[sp].vb or store^[sp + 1].vb
                        end;

45 (*dif*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vs := store^[sp].vs - store^[sp + 1].vs
                        end;

46 (*int*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vs := store^[sp].vs * store^[sp + 1].vs
                        end;

47 (*uni*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vs := store^[sp].vs + store^[sp + 1].vs
                        end;

48 (*inn*)
                    :
                        begin
                            sp := sp - 1;
                            i := store^[sp].vi;
                            store^[sp].vb := i in store^[sp + 1].vs;
                        end;

49 (*mod*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vi := store^[sp].vi mod store^[sp + 1].vi
                        end;

50 (*odd*)
                    :
                        store^[sp].vb := odd(store^[sp].vi);

51 (*mpi*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vi := store^[sp].vi * store^[sp + 1].vi
                        end;

52 (*mpr*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vr := store^[sp].vr * store^[sp + 1].vr
                        end;

53 (*dvi*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vi := store^[sp].vi div store^[sp + 1].vi
                        end;

54 (*dvr*)
                    :
                        begin
                            sp := sp - 1;
                            store^[sp].vr := store^[sp].vr / store^[sp + 1].vr
                        end;

55 (*mov*)
                    :
                        begin
                            i1 := store^[sp - 1].va;
                            i2 := store^[sp].va;
                            sp := sp - 2;
                            for i := 0 to q - 1 do
                                store^[i1 + i] := store^[i2 + i]
               (* q is a number of storage units *)
                        end;

56 (*lca*)
                    :
                        begin
                            sp := sp + 1;
                            store^[sp].va := q;
                        end;

                    100, 101, 102, 103, 104, 57 (*dec*)
                    :
                        store^[sp].vi := store^[sp].vi - q;

58 (*stp*)
                    :
                        interpreting := false;

59 (*ord*)
                    : (*only used to change the tagfield*)
                        begin
                        end;

60 (*chr*)
                    :
                        begin
                        end;

61 (*ujc*)
                    :
                        errori(' case - error        ');
                end
            end; (*while interpreting*)

1:
        close(prd);

{Exit:}
        ConsoleNewLine;
        if aborted then
            ConsoleWriteln('•••Execution terminated by user•••')
        else
            ConsoleWriteln('•••');

{Writeln('Hit return to exit');}
{readln(oldFile); {read to anything}
{writeln('Click mouse to exit.');}
{while not Button do ;}
    end;

end.